Chip 2000 November/Chip Kasım 2000.iso/prog/share/11/setup.exe/%MAINDIR%/DEMOS/CISERVER/CHAT/CHATHOST/frmHost.frm

Visual Basic Form | 2000-09-07 | 6.4 KB | 179 lines

VERSION 4.00
Begin VB.Form Form1
   Caption         =   "Chat Server"
   ClientHeight    =   3600
   ClientLeft      =   3165
   ClientTop       =   1560
   ClientWidth     =   4605
   Height          =   4080
   Left            =   3105
   LinkTopic       =   "Form1"
   ScaleHeight     =   3600
   ScaleWidth      =   4605
   Top             =   1140
   Width           =   4725
   Begin VB.TextBox txtPort
      Height          =   285
      Left            =   90
      TabIndex        =   5
      Text            =   "2000"
      Top             =   1170
      Width           =   1365
   End
   Begin VB.CommandButton cmdStart
      Caption         =   "Start Chat Server"
      Height          =   375
      Left            =   90
      TabIndex        =   4
      Top             =   1800
      Width           =   1365
   End
   Begin VB.ListBox lstNames
      Height          =   3180
      Left            =   1710
      TabIndex        =   2
      Top             =   360
      Width           =   2805
   End
   Begin VB.TextBox txtConnections
      Height          =   315
      Left            =   90
      TabIndex        =   1
      Text            =   "10"
      Top             =   360
      Width           =   1365
   End
   Begin VB.Label Label3
      Caption         =   "Port Number:"
      Height          =   195
      Left            =   90
      TabIndex        =   6
      Top             =   900
      Width           =   1455
   End
   Begin VB.Label Label2
      Caption         =   "Currently connected:"
      Height          =   285
      Left            =   1710
      TabIndex        =   3
      Top             =   90
      Width           =   2445
   End
   Begin CISERVERLib.CIServer svrChat
      Left            =   540
      Top             =   2880
      _Version        =   65536
      _ExtentX        =   847
      _ExtentY        =   794
      _StockProps     =   0
   End
   Begin VB.Label Label1
      Caption         =   "Max. Connections:"
      Height          =   195
      Left            =   90
      TabIndex        =   0
      Top             =   90
      Width           =   1455
   End
Attribute VB_Name = "Form1"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'~~~ SUBJECT:     Crescent Internet ToolPak CISERVER Client Demo
'~~~ AUTHOR:      Bob Follet
'~~~ DATE:        December 1, 1997
'~~~ MODIFIED:
'~~~ DESCRIPTION: Crescent Internet ToolPak CISERVER Server Demo.  This Demo provides
'~~~              details on how to use the CISERVER Control.  This demo receives
'~~~              messages from the CISERVER Client Demo and returns a response. See
'~~~              The CISERVER Chat Demo for further information.
'~~~ ADDITIONS:   No Additions. This is a New Demo to Internet ToolPak
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Dim MaxClients As Integer
Private Sub cmdStart_Click()
' Start Running the Server
Dim temp As Variant
If svrChat.ListenMode = 0 Then 'Will not accept connections if 0
    MaxClients = Val(txtConnections.Text) ' maximum number of connections to server
    temp = Int(Val(txtPort.Text))
    'Determine if port number is valid
    If temp < -32768 Or temp > 32767 Or temp = 0 Then 'invalid port
        MsgBox "Port number must be between -32768 and 32767 excluding the value of zero", 0, "Invalid Parameter"
        txtPort.SelStart = 0
        txtPort.SelLength = Len(txtPort.Text)
        txtPort.SetFocus
        Exit Sub
    End If
    svrChat.Port = temp
    svrChat.ListenMode = 1 'start accepting connections
    cmdStart.Caption = "Exit"
Else 'Exit application
    If svrChat.Clients.Count <> 0 Then
        i = MsgBox("There are still active connections.  Are you sure you want to Exit?", 4)
        If i = vbYes Then End
    Else
        End
    End If
End If

End Sub
Private Sub svrChat_ClientSocketError(ByVal FromClient As Object, ByVal ErrorNumber As Integer)
' An Error was generated, display results
Debug.Print "ClientSocketError  from " & FromClient.Address & " Error number= " & ErrorNumber
End Sub
Private Sub svrChat_ConnectionAttempt(ByVal NewClient As Object, AcceptConnection As Boolean)
'test if maximum connections has been reached
If svrChat.Clients.Count = MaxClients Then 'deny connecion
    NewClient.Send "Sorry, No more connections accepted at this time"
    AcceptConnection = False
End If
End Sub
Private Sub svrChat_PacketReceived(ByVal FromClient As Object, Packet As Variant, ByVal BytesRec As Integer)
Dim x As Client
Dim i As Integer
Dim message As String
' Check if a client is sending a chat message, its ScreenName or is disconnecting.
' ~| is used by this demo to denote a message to the server when a client
'  is sending its screen name or is disconnecting.  Any other packet is
'  distributed as a chat message
If InStr(Packet, "~|") Then
    If InStr(Packet, "name") Then 'client is sending screen name
        lstNames.AddItem Right(Packet, Len(Packet) - 7)
        'send name list to all client
        message = "<Names>"
        For i = 0 To lstNames.ListCount - 1
            message = message & lstNames.List(i) & Chr(13)
        Next i
        ' Display the message to each client who is connected, in the collection.
        For Each x In svrChat.Clients
            x.Send message
        Next
    ElseIf InStr(Packet, "exit") Then 'test for disconnect
        'remove screen name from listbox
        For i = 0 To lstNames.ListCount
            If Right$(Packet, Len(Packet) - 6) = lstNames.List(i) Then
                lstNames.RemoveItem i
                Exit For
            End If
        Next i
        'create new list of screen names
        message = "<Names>"
        For i = 0 To lstNames.ListCount - 1
            message = message & lstNames.List(i) & Chr(13)
        Next i
        'send new list of screen names to all clients
        For Each x In svrChat.Clients
            x.Send message
        Next
    End If
Else ' Chat message > forward to all clients connected
    For Each x In svrChat.Clients
        x.Send Packet
    Next
End If
End Sub
Private Sub svrChat_SocketError(ByVal ErrorNumber As Integer)
' An error was detected, display results.
Debug.Print "SocketError #" & ErrorNumber & " occured"
End Sub